Unit Funktion;

interface

Type CodeTyp = (Zahl,Plus,Minus,Mal,Durch,Hoch,Groessergleich,Kleinergleich,
                Gleich,Ungleich,Groesser,Kleiner,Und,Oder,KlammerZu,KlammerAuf,
                Wurzel,Quadrat,Absolut,Gauss,Exponential,Logarithmus,
                Cosinus,Sinus,Tangens,ArcCosinus,ArcSinus,ArcTangens,
                Pi,E,X,Y,Ende,EinstMinus,Undefiniert);

     EintragsTyp        = Record
                           Code       : CodeTyp;
                           Zahl       : Real;
                           Einstellig : Boolean;
                          End;
     FunktionsTyp       = Record
                           Data     : Array [0..70] of EintragsTyp;
                           Position : Integer;
                           Init     : Real;
                           Beendet  : Boolean;
                          End;

 Procedure StringToFunktion( St           : String;
                             Var Funktion : FunktionsTyp;
                             Var Error    : Boolean);

 Function Wert( Var Funktion : FunktionsTyp;
                XWert, YWert : Real;
                Var Error    : Boolean)            :Real;

 Function FunktionToString(Var Funktion:FunktionsTyp):String;

Implementation

Uses SysUtils;


Const Pi_Wert         : Real = 3.14159265359;
      E_Wert          : Real = 2.71828182844;

Type StringTyp          = Array [Zahl..Ende] of String[10];

Const ParseData : StringTyp =
       ('','+','-','*','/','^','>=','<=','=','<>','>','<','AND','OR',')','(',
        'SQRT(','SQR(','ABS(','INT(','EXP(','LN(','COS(','SIN(','TAN(',
        'ARCCOS(','ARCSIN(','ARCTAN(','PI','E','X','Y','');

 Function AlterCode(Var Funktion:FunktionsTyp):CodeTyp;
  Begin
   If Funktion.Position = 0 then AlterCode := Undefiniert
   else AlterCode := Funktion.Data[Funktion.Position].Code;
  End;

 Function HoleZahl(Var Funktion:FunktionsTyp):Real;
  Begin
   HoleZahl := Funktion.Data[Funktion.Position].Zahl;
  End;

 Function NextCode(Var Funktion:FunktionsTyp):CodeTyp;
  Begin
   If ((AlterCode(Funktion) <> Ende) And (Funktion.Position < 255)) Or
      (Funktion.Position = 0) then
    Begin
     Inc(Funktion.Position);
     NextCode := AlterCode(Funktion);
    End else NextCode := Ende;
  End;

 Procedure InitFunktion(Var Funktion:FunktionsTyp);
  Begin
   If Funktion.Init <> Pi_Wert then
    Begin
     Funktion.Position := 0;
     Funktion.Init := Pi_Wert;
     Funktion.Beendet := False;
    End;
  End;

 Procedure ResetFunktion(Var Funktion:FunktionsTyp);
  Begin
   Funktion.Position := 0;
   Funktion.Init := 0;
  End;

 Function EOFAusdruck(Var Funktion:FunktionsTyp):Boolean;
  Var Code : CodeTyp;
  Begin
   If Not Funktion.Beendet then
    Begin
     Code := NextCode(Funktion);
     Dec(Funktion.Position);
    End;
   EOFAusdruck := (Code = KlammerZu) or (Code = Ende) or (Funktion.Beendet);
  End;

 Function EOFFunktion(Var Funktion:FunktionsTyp):Boolean;
  Var Code : CodeTyp;
  Begin
   If Funktion.Beendet then EOFFunktion := True
    else
     Begin
      Code := NextCode(Funktion);
      If Code = Ende then Funktion.Beendet := True;
      Dec(Funktion.Position);
      EOFFunktion := (Code = Ende);
     End;
  End;

 Function OperationKleiner(Code,SCode:CodeTyp):Boolean;
  Begin
   Case Code of
    Und, Oder  :  OperationKleiner := True;
    Groesser, Kleiner, Kleinergleich, Groessergleich, Gleich,
    Ungleich   :  OperationKleiner :=(SCode = Kleiner) Or
                                     (SCode=Groesser) Or (SCode=Gleich) Or
                                     (SCode=Kleinergleich) Or
                                     (SCode=Groessergleich) Or
                                     (SCode=Ungleich) Or
                                     (SCode=Plus) Or (SCode=Minus) Or
                                     (SCode=Mal) Or (SCode=Durch) Or
                                     (SCode=Hoch);
    Plus,Minus : OperationKleiner := (SCode=Plus) Or (SCode=Minus) Or
                                     (SCode=Mal) Or (SCode=Durch) Or
                                     (SCode=Hoch);
    Mal,Durch  : OperationKleiner := (SCode=Mal) Or (SCode=Durch) Or
                                     (SCode=Hoch);
    Hoch       : OperationKleiner := (SCode = Hoch);
   End;
  End;

 Procedure RangeCheck(Var C:Extended; Var Error:Boolean);
  Begin
   If abs(C) < 1E-39 then C := 0
    else if abs(C) > 1E38 then
     Begin
      C := 0;
      Error := True;
     End;
  End;

 Function DividiereDurch(A,B:Real; Var Error:Boolean):Real;
  Var C : Extended;
  Begin
   If B <> 0 then
    Begin
     C := A/B;
     RangeCheck(C,Error);
     DividiereDurch := C;
    End
   else
   Begin
     Error := True;
     DividiereDurch := 0;
    End;
  End;

 Function Tan(Wert:Real; Var Error:Boolean):Real;
  Begin
   Tan := DividiereDurch(Sin(Wert),Cos(Wert),Error);
  End;

 Function ArcSin(Wert:Real; Var Error:Boolean):Real;
  Var C : Extended;
  Begin
   C := 1-Wert*Wert;
   RangeCheck(C,Error);
   If C >= 0 then ArcSin := ArcTan(DividiereDurch(Wert,Sqrt(C),Error))
    else Begin
          ArcSin := 0;
          Error := True;
         End;
  End;

 Function ArcCos(Wert:Real; Var Error:Boolean):Real;
  Var C : Extended;
  Begin
   C := Pi_Wert/2 - ArcSin(Wert,Error);
   RangeCheck(C,Error);
   ArcCos := C;
  End;

 Function Wert( Var Funktion : FunktionsTyp;
                XWert, YWert     : Real;
                Var Error    : Boolean):Real;

  Const MaxStack   = 20;
  Var Stack        : Array [1..MaxStack] of EintragsTyp;
      StackPointer : Integer;
      Code         : CodeTyp;
      B            : Real;
      C            : Extended;


 Procedure StackAuswerten(Operator:CodeTyp);
  Var A, B : Real;
      C    : Extended;
      Neg  : Boolean;

 Function Gerade(Zahl:Real):Boolean;
  Begin
   Gerade := (frac(Zahl/2)=0);
  End;

  Begin
   While (StackPointer>1) And
         ((OperationKleiner(Operator,Stack[StackPointer-1].Code)) Or
         (Stack[StackPointer-1].Einstellig)) Do
    Begin
     B := Stack[StackPointer].Zahl;
     Dec(StackPointer);
     A := Stack[StackPointer].Zahl;
     Case Stack[StackPointer].Code of
      Plus  : C := A+B;
      Minus : C := A-B;
      Mal   : C := A*B;
      Durch : C := DividiereDurch(A,B,Error);
      Hoch  : Begin
               Neg := (A<0) And Not Gerade(B);
               If (A > 0) Or (Frac(B)=0) then C := Ln(abs(A))*B else
                Begin
                 Error := True;
                 C := 0;
                End;
               If C < -90 then C := 0
                else If C < 300 then C := Exp(C)
                      else Error := True;
               If Neg then C := -C;
              End;
      Groesser : If A>B then C := 1 else C := 0;
      Kleiner  : If A<B then C := 1 else C := 0;
      Groessergleich : If (A>B) or (Abs(A-B) < 0.000001) then C := 1 else C := 0;
      Kleinergleich : If (A<B) or (Abs(A-B) < 0.000001) then C := 1 else C := 0;
      Gleich   : If Abs(A-B) < 0.000001 then C := 1 else C := 0;
      Ungleich : If Abs(A-B) > 0.000001 then C := 1 else C := 0;
      Und      : If (A>0.5) And (B>0.5) then C := 1 else C := 0;
      Oder     : If (A+B>0.5) then C := 1 else C := 0;
     End;
     RangeCheck(C,Error);
     Stack[StackPointer].Zahl := C;
    End;
  End;

 Procedure ZahlInStack(Wert:Real; Var Error:Boolean);
  Begin
   Inc(StackPointer);
   If StackPointer>MaxStack then Error := True
    else Stack[StackPointer].Zahl := Wert;
  End;

 Procedure OperationInStack(Code:CodeTyp);
  Begin
   If StackPointer = 0 then
    Begin
     StackPointer := 1;
     Stack[StackPointer].Zahl := 0;
    End;
   Stack[StackPointer].Code := Code;
   Stack[StackPointer].Einstellig := False;
  End;

  Var LetzterCode : CodeTyp;
  Begin
   LetzterCode := Oder;
   Error := False;
   InitFunktion(Funktion);
   StackPointer := 0;
   Repeat
    Code := NextCode(Funktion);
    If Code <> Ende then
     If (Code = Zahl) Or ((Code=Pi) Or (Code=E) Or (Code=X) Or (Code=Y)) then
      Begin
       LetzterCode := Zahl;
       If Code = Zahl then ZahlInStack(HoleZahl(Funktion),Error)
        else
         Case Code of
          Pi : ZahlInStack(Pi_Wert,Error);
          E  : ZahlInStack(E_Wert,Error);
          X  : ZahlInStack(XWert,Error);
          Y  : ZahlInStack(YWert,Error);
         End
      End
     else
      If (Code=Plus) Or (Code=Minus) Or (Code=Mal) Or (Code=Durch) Or
         (Code=Hoch) Or (Code=Groesser) Or (Code=Kleiner) Or
         (Code=Kleinergleich) Or (Code=Groessergleich) Or (Code=Ungleich) Or
         (Code=Gleich) Or (Code=Und) Or (Code=Oder) then
       Begin
        If (LetzterCode = Plus) then
         If (Code=Minus) Or (Code=Plus) then
          Begin
           ZahlInStack(0,Error);
           OperationInStack(Code);
           Stack[StackPointer].Einstellig := True;
          End else Error := True
        else
         Begin
          StackAuswerten(Code);
          OperationInStack(Code);
          LetzterCode := Plus;
         End;
       End
      else
       Begin
        LetzterCode := KlammerAuf;
        Case Code Of
         KlammerAuf  : ZahlInStack(Wert(Funktion,XWert,YWert,Error),Error);
         Wurzel      : Begin
                        B := Wert(Funktion,XWert,YWert,Error);
                        If B > 0 then ZahlInStack(Sqrt(B),Error)
                         else
                          Begin
                           ZahlInStack(0,Error);
                           Error := True;
                          End;
                       End;
         Quadrat     : Begin
                        C := Sqr(Wert(Funktion,XWert,YWert,Error));
                        RangeCheck(C,Error);
                        ZahlInStack(C,Error);
                       End;
         Absolut     : ZahlInStack(Abs(Wert(Funktion,XWert,YWert,Error)),Error);
         Gauss       : ZahlInStack(Int(Wert(Funktion,XWert,YWert,Error)),Error);
         Exponential : Begin
                        B :=Wert(Funktion,XWert,YWert,Error);
                        If B < -90 then C := 0
                         else If B < 300 then C := Exp(B)
                               else Error := True;
                        RangeCheck(C,Error);
                        ZahlInStack(C,Error);
                       End;
         Logarithmus : Begin
                        B := Wert(Funktion,XWert,YWert,Error);
                        If B > 0 then ZahlInStack(Ln(B),Error)
                         else
                          Begin
                           Error := True;
                           ZahlInStack(0,Error);
                          End;
                       End;
         Cosinus     : ZahlInStack(Cos(Wert(Funktion,XWert,YWert,Error)),Error);
         Sinus       : ZahlInStack(Sin(Wert(Funktion,XWert,YWert,Error)),Error);
         Tangens     : ZahlInStack(Tan(Wert(Funktion,XWert,YWert,Error),Error),Error);
         ArcCosinus  : ZahlInStack(ArcCos(Wert(Funktion,XWert,YWert,Error),Error),Error);
         ArcSinus    : ZahlInStack(ArcSin(Wert(Funktion,XWert,YWert,Error),Error),Error);
         ArcTangens  : ZahlInStack(ArcTan(Wert(Funktion,XWert,YWert,Error)),Error);
        End;
       End;
   Until EOFAusdruck(Funktion) Or Error;
   StackAuswerten(Oder);
   If Error then Wert := 0
    else Wert := Stack[1].Zahl;
   If Error Or EOFFunktion(Funktion) then ResetFunktion(Funktion);
   Code := NextCode(Funktion);
  End;

 Function KillEndNullen(St:String):String;
  Begin
   If Pos('E',St) = 0 then
    Begin
     While (Copy(St,Length(St),1) = '0') do St := Copy(St,1,Length(St)-1);
     If (Copy(St,Length(St),1) = '.') then St := Copy(St,1,Length(St)-1);
    End;
   KillEndNullen := St;
  End;

 Function FunktionToString(Var Funktion:FunktionsTyp):String;
  Var Code         : CodeTyp;
      Ergebnis, St : String;
  Begin
   Ergebnis := '';
   InitFunktion(Funktion);
   Repeat
    Code := NextCode(Funktion);
    If Code = Zahl then
     Begin
      St := Format('%.10g',[HoleZahl(Funktion)]);
      If St = '' then St := '0';
      Ergebnis := Ergebnis + St + ' ';
     End
    else Ergebnis := Ergebnis + UpperCase(ParseData[Code]) + ' ';
   Until EOFFunktion(Funktion);
   FunktionToString := Ergebnis;
   ResetFunktion(Funktion);
  End;

 Procedure Normierung(St:String; Var St1 : String);
  Var T       : Integer;
      Zeichen : Char;
  Begin
   St1 := '';
   For T := 1 to Length(St) do
    Begin
     Zeichen := Upcase(St[T]);
     If Zeichen <> ' ' then St1 := St1+ Zeichen;
    End;
  End;

 Procedure StringToFunktion( St           : String;
                             Var Funktion : FunktionsTyp;
                             Var Error    : Boolean);
  Var Stelle, Lauf : Integer;
      FString      : String;
      Code         : CodeTyp;

  Function ParseNextCode:CodeTyp;
   Var C            : Char;
       Code         : CodeTyp;
       CodeGefunden : Boolean;
       S            : String;
   Begin
    If Stelle > Length(FString) then ParseNextCode := Ende
     else
      Begin
       C := FString[Stelle];
       If ((C>='0') And (C<='9')) Or (C='.') Or (C=',') then
        ParseNextCode := Zahl
        else
         Begin
          Code := Plus;
          CodeGefunden := False;
          Repeat
           S := Copy(FString,Stelle,Length(ParseData[Code]));
           If ParseData[Code] = Copy(FString,Stelle,Length(ParseData[Code]))
            then CodeGefunden := True;
           If Not CodeGefunden then Code := Succ(Code);
          Until CodeGefunden Or (Code = Ende);
          If CodeGefunden then Stelle := Stelle + Length(ParseData[Code]);
          ParseNextCode := Code;
         End;
      End;
   End;

  Function ParseZahl:Real;
   Const ZahlParseData : Array [1..15] of String[2] =
                         ('0','1','2','3','4','5','6','7','8','9','E+','.',',',
                          'E-','E');
   Var Zahl       : String;
       Lauf, Loop : Integer;
       LoopEnde   : Boolean;
       ValZahl    : Real;
   Begin
    Zahl := '0';
    Lauf := 0;
    LoopEnde := False;
    Repeat
     Loop := 1;
     While (Stelle+Lauf<=Length(FString)) And (Loop<16) And
           (Copy(FString,Stelle+Lauf,Length(ZahlParseData[Loop]))
           <>ZahlParseData[Loop]) Do Inc(Loop);
     If (Loop<16) And (Stelle+Lauf<=Length(FString)) then
      Begin
       If Loop = 13 then Zahl := Zahl + '.'
        else Zahl := Zahl + ZahlParseData[Loop];
       Lauf := Lauf + Length(ZahlParseData[Loop]);
      End
     else LoopEnde := True;
    Until LoopEnde;
    Val(Zahl,ValZahl,Loop);
    ParseZahl := ValZahl;
    Stelle := Stelle + Lauf;
   End;

  Begin
   Error := False;
   Stelle := 1;
   Lauf := 1;
   Funktion.Init := 0;
   Funktion.Position := 0;
   Normierung(St,FString);
   Repeat
    Code := ParseNextCode;
    Funktion.Data[Lauf].Code := Code;
    If Code = Zahl then Funktion.Data[Lauf].Zahl := ParseZahl
     else Funktion.Data[Lauf].Zahl := 0;
    Inc(Lauf);
   Until (Code = Ende);
  End;

  { *********************************************************************** }

 End.
